Shareware Grab Bag/Shareware Grab Bag.iso/090/vol7n2.arc/TP4.FIG

Text File | 1987-12-08 | 19.1 KB | 684 lines

Fig. A -- Heading for an Interrupt Procedure

PROCEDURE foo(_Flags, _CS, _IP, _AX, _BX, _CX, _DX, _SI, _DI, _DS, _ES,
_BP:Word);INTERRUPT;


Fig. B -- Special prelude and postlude code created by TP4 for an Interrupt
Procedure

 50           PUSH   AX
 53           PUSH   BX
 51           PUSH   CX
 52           PUSH   DX
 56           PUSH   SI
 57           PUSH   DI
 1E           PUSH   DS
 06           PUSH   ES
 55           PUSH   BP
 89E5         MOV    BP,SP
 81ECxxxx     SUB    SP,LocalSize
 B8yyyy       MOV    AX,SEG DATA
 8ED8         MOV    DS,AX
 {Body of procedure goes here}
 89EC         MOV    SP,BP
 5D           POP    BP
 07           POP    ES
 1F           POP    DS
 5F           POP    DI
 5E           POP    SI
 5A           POP    DX
 59           POP    CX
 5B           POP    BX
 58           POP    AX
 CF           IRET

Fig. C -- An chaining Interrupt Procedure

PROGRAM Shift_Key_Pressed;
  Uses crt, dos, hexx;
  (*The hexx Unit is described elsewhere in this article*)
VAR
  Kbd_Vec, Exit_Vec : pointer;
CONST
  Kbd_Int = 9;
  (* Scan codes for seven shift keys *)
  SC_LeftShift  = 42;
  SC_RightShift = 54;
  SC_CtrlShift  = 29;
  SC_AltShift   = 56;
  SC_NumLock    = 69;
  SC_ScrollLock = 70;
  SC_CapsLock   = 58;
  SKP : Boolean = False;
  which : Byte  = 0;

  {$F+} PROCEDURE My_Exit;   {$F-}
  BEGIN
    SetIntVec(Kbd_Int, Kbd_vec); {restore OLD INT9}
    IF (ExitCode <> 0) OR (ErrorAddr <> NIL) THEN
      BEGIN
        Assign(Output, '');
        Rewrite(Output);
        WriteLn(#7);
        IF ExitCode = $FF THEN
          WriteLn('USER BREAK')
        ELSE
          BEGIN
            Write('Critical Error # ', HEX(ExitCode));
            Write(' AT PROGRAM LOCATION ');
            WriteLn(Hex(Seg(ErrorAddr^)), ':', Hex(Ofs(ErrorAddr^)));
          END;
      END;
    ExitProc := Exit_Vec;     {restore previous ExitProc}
  END;

  PROCEDURE CLI; INLINE($FA); {INLINE procedures are handy!}
  PROCEDURE STI; INLINE($FB);

  PROCEDURE INT9_ISR(_Flags, _CS, _IP, _AX, _BX, _CX, _DX,
                         _SI, _DI, _DS, _ES, _BP : word);
  INTERRUPT;
  BEGIN
    INLINE(
      $9C/                {PUSHF ;save flags }
      $E4/$60/            {IN AL, 60h ;Read the keyboard port }
      $3C/SC_CapsLock/    {CMPB AL,SC_CapsLock  }
      $74/$1F/            {JZ Was_Pressed       }
      $3C/SC_LeftShift/   {CMPB AL,SC_LeftShift }
      $74/$1B/            {JZ Was_Pressed       }
      $3C/SC_RightShift/  {CMPB AL,SC_RightShift}
      $74/$17/            {JZ Was_Pressed       }
      $3C/SC_CtrlShift/   {CMPB AL,SC_CtrlShift }
      $74/$13/            {JZ Was_Pressed       }
      $3C/SC_AltShift/    {CMPB AL,SC_AltShift  }
      $74/$0F/            {JZ Was_Pressed       }
      $3C/SC_NumLock/     {CMPB AL,SC_NumLock   }
      $74/$0B/            {JZ Was_Pressed       }
      $3C/SC_ScrollLock/  {CMPB AL,SC_ScrollLock}
      $74/$07/            {JZ Was_Pressed       }

      {IF you didn't jump by now, it wasn't a shift key}
      $C6/$06/SKP/$00/    {MOVB SKP,0 ;set SKP to false    }
      $EB/$08/            {JMP To_Normal}

      {Was_Pressed}
      $C6/$06/SKP/$01/    {MOVB SKP,1 ;set SKP to true       }
      $A2/which/          {MOVB which,AL ;remember WHICH key    }

      {To_Normal}
      $9D/                {POPF ;Get back saved flags   }
      $A1/> Kbd_vec+2/    {MOV AX,Kbd_vec+2 ; vector segment }
      $8B/$1E/> Kbd_vec/  {MOV BX,Kbd_vec   ; vector offset  }
      $87/$5E/$0E/        {XCHG BX,[BP+14]  ; switch ofs/bx  }
      $87/$46/$10/        {XCHG AX,[BP+16]  ; switch seg/ax  }

      $8B/$E5/            {MOV SP,BP ;UNdo what TURBO did at }
      $5D/                {POP BP    ;start of this routine}
      $07/                {POP ES    ;It does a lot more than TP3!}
      $1F/                {POP DS}
      $5F/                {POP DI}
      $5E/                {POP SI}
      $5A/                {POP DX}
      $59/                {POP CX}
      $CB                 {RETF ; effectively "JMP [Kbd_vec]" }
      );
  END;

  FUNCTION ShiftKeyPressed : Boolean;
    (* ======================================= *)
    (* Returns the value of flag variable SKP, *)
    (* and resets it to FALSE                  *)
    (* ======================================= *)
  BEGIN
    CLI; {Don't want it changing DURING this!}
    ShiftKeyPressed := SKP;
    SKP := False;
    STI; {OK, can change now}
  END;

  FUNCTION Read_SKP : Byte;
    (* ================================== *)
    (* Returns the value of flag variable *)
    (* "WHICH", and resets it to 0        *)
    (* ================================== *)
  BEGIN
    CLI; {Don't want it changing DURING this!}
    Read_SKP := which;
    which := 0;
    STI; {OK, can change now}
  END;

  PROCEDURE Do_Demo;
  BEGIN
    ClrScr;
    WriteLn('   KEYBOARD INTERRUPT DEMO "Shift Keys"');
    WriteLn('   ====================================');
    WriteLn;
    Write('   Press the various shift keys on the ');
    WriteLn('keyboard.  The normal "KeyPressed"');
    Write('   function doesn''t notice these keys.  ');
    WriteLn('But the new "ShiftKeyPressed"');
    WriteLn('   notices!  Hit <Ctrl><Break> to quit.');
    REPEAT
      REPEAT UNTIL KeyPressed OR ShiftKeyPressed;
      WHILE KeyPressed DO Write(ReadKey);
      CASE Read_SKP OF
        SC_LeftShift  : WriteLn('Left Shift');
        SC_RightShift : WriteLn('Right Shift');
        SC_CtrlShift  : WriteLn('Control Shift');
        SC_AltShift   : WriteLn('Alt Shift');
        SC_NumLock    : WriteLn('Num Lock');
        SC_ScrollLock : WriteLn('Scroll Lock');
        SC_CapsLock   : WriteLn('Caps Lock');
      END;
    UNTIL False;          {Only way out is ^Break}
  END;

BEGIN
  CheckBreak := True;
  GetIntVec(Kbd_Int, Kbd_Vec);   {save "old" INT9}
  SetIntVec(Kbd_Int, @INT9_ISR); {install new}
  Exit_Vec := ExitProc;          {save old ExitProc}
  ExitProc := @My_Exit;          {install new}
  Do_Demo;                       {show yer stuff!}
END.

Fig. D -- An Interrupt Procedure that replaces Interrupt 16h

PROGRAM New_I16;
  Uses crt, dos, hexx;
  (*The hexx Unit is described elsewhere in this article*)
VAR
  Kbd_Vec, Exit_Vec : pointer;
CONST
  Kbd_Int = $16;

  {$F+} PROCEDURE My_Exit;   {$F-}
  BEGIN
    SetIntVec(Kbd_Int, Kbd_vec); {restore OLD INT16}
    IF (ExitCode <> 0) OR (ErrorAddr <> NIL) THEN
      BEGIN
        Assign(Output, '');
        Rewrite(Output);
        WriteLn(#7);
        IF ExitCode = $FF THEN
          WriteLn('USER BREAK')
        ELSE
          BEGIN
            Write('Critical Error # ', HEX(ExitCode));
            Write(' AT PROGRAM LOCATION ');
            WriteLn(Hex(Seg(ErrorAddr^)), ':', Hex(Ofs(ErrorAddr^)));
          END;
      END;
    ExitProc := Exit_Vec;     {restore previous ExitProc}
  END;


  PROCEDURE CLI; INLINE($FA); {INLINE procedures are NICE!}
  PROCEDURE STI; INLINE($FB);
  PROCEDURE NOP; INLINE($90);

  PROCEDURE INT16_ISR(_Flags, _CS, _IP, _AX, _BX, _CX, _DX,
                              _SI, _DI, _DS, _ES, _BP : word);
    INTERRUPT;
  (*THIS procedure simply duplicates the function of (un-enhanced BIOS)
    INT 16h.  But it does it totally using Turbo Pascal!*)
  CONST
    Zero_Flag = $40;
    BIOS_Data = $40;
  VAR
    Buffer_Head  : Integer ABSOLUTE BIOS_Data : $001A;
    Buffer_Tail  : Integer ABSOLUTE BIOS_Data : $001C;
    Buffer_Start : Integer ABSOLUTE BIOS_Data : $0080;
    Buffer_End   : Integer ABSOLUTE BIOS_Data : $0082;
    KB_Flag      : Byte ABSOLUTE BIOS_Data : $0017;
  BEGIN
    STI;
    CASE Hi(_AX) OF
      0 : BEGIN         (*Read key (wait for it)*)
            REPEAT
              STI; NOP; CLI;
            UNTIL Buffer_Head <> Buffer_Tail;
            _AX := MemW[BIOS_Data : Buffer_Head];
            INC(Buffer_Head, 2);
            IF Buffer_Head > Buffer_End THEN
              Buffer_Head := Buffer_Start;
            STI;
          END;
      1 : BEGIN         (* Was a key pressed?*)
            CLI;
            IF Buffer_Head = Buffer_Tail THEN
              _Flags := _Flags OR Zero_Flag
            ELSE
              BEGIN
                _Flags := _Flags AND NOT(Zero_Flag);
                _AX := MemW[BIOS_Data:Buffer_Head];
              END;
            STI;
          END;
      2 : _AX := KB_Flag; (*Return shift states*)
    END;
  END;

  PROCEDURE Do_Demo;
  VAR
    CH : Char;
    L : STRING[255];
    I : Integer;
  BEGIN
    WriteLn('Replacement keyboard interrupt is installed.');
    Write('PRESS any key to continue....');
    REPEAT UNTIL KeyPressed;
    CH := ReadKey;
    WriteLn(CH);
    Write('Enter your name: ');
    ReadLn(L);
    WriteLn('Hi, ', L);
    Write('Enter an integer: ');
    ReadLn(I);
    WriteLn('You entered ', I);
  END;

BEGIN
  ClrScr;
  CheckBreak := True;
  GetIntVec(Kbd_Int, Kbd_Vec);    {save "old" INT16}
  SetIntVec(Kbd_Int, @INT16_ISR); {install new}
  Exit_Vec := ExitProc;           {save old ExitProc}
  ExitProc := @My_Exit;           {install new}
  Do_Demo;                        {show yer stuff!}
  {The interrupt gets restored in the ExitProc}
END.

Fig. E -- One way to call a procedure within INLINE code

PROGRAM ProcParmDemo;
VAR P : pointer;

{$F+}
 PROCEDURE aproc;
 BEGIN
   WriteLn('I am a procedure!');
 END;
{$F-}

PROCEDURE Call(Pro : pointer);
 BEGIN
   INLINE($FF/$5E/$04); {CALL FAR [BP+4]}
 END;

BEGIN
 P := @aproc;
 call(P);
END.

Fig. F -- Fast keypress detection using an INLINE directive

PROGRAM InlineDirective1;
  USES crt;
VAR
  CH : Char;
  count : LongInt;

  PROCEDURE FastKey; INLINE
      ($31/$C0/                {XOR AX,AX}
       $8E/$C0/                {MOV ES,AX}
       $26/$A1/$1A/$04/        {MOV AX,ES:[041A]}
       $26/$3B/$06/$1C/$04/    {CMP AX,ES:[041C]}
       $74/$03);               {JZ  $+3}

  PROCEDURE GetCh;
  BEGIN CH := UpCase(ReadKey); END;

BEGIN
  WriteLn('Press any key to start, "Q" to Quit');
  CH := ReadKey;
  WriteLn('Looping....');
  CH := #0;
  count := 0;
  REPEAT
    FastKey;
    GetCh;
    Inc(Count);
  UNTIL CH = 'Q';
  WriteLn('IN that time I performed ', count, ' repetitions');
END.

Fig. G -- An INLINE directive with arguments

PROGRAM LongMulDemo;
VAR
  X, Y : Integer;

  FUNCTION LongMul(X, Y : Integer) : LongInt;
    (* Turbo pushes X and Y on the stack *)
  INLINE(
    $58/                    {POP AX  ;Pop Y }
    $5A/                    {POP DX  ;Pop X }
    $F7/$EA);               {IMUL DX ;Result in DX:AX = X*Y}

BEGIN
  X := MaxInt; Y := MaxInt;
  WriteLn('X is ', X, ' and Y is ', Y);
  WriteLn('X*Y=', X*Y, ' -- wrong because it''s truncated to integer.');
  WriteLn('LongMul(X,Y)=', LongMul(X, Y));
  WriteLn('LongInt(X)*Y=', LongInt(X)*Y);
END.

Fig. H -- Example of a shared data type for inter-process communication

TYPE
  PassData = RECORD
    ID           : string[8];
    status       : Integer;
    DataFileName : string[64];
  END;

Fig. I -- An ExitProc gets control when the program ends.

{$R+}
PROGRAM Exit_Proc_Demo;
  USES Crt, hexx;
  (*The hexx Unit is described elsewhere in this article*)
VAR
  ExitVec : Pointer;
  W : Word;

  {$F+} PROCEDURE My_ExitProc; {$F-}
  BEGIN
    IF (ExitCode <> 0) OR (ErrorAddr <> NIL) THEN
      BEGIN
        Assign(Output, '');   (*Use DOS Standard Output*)
        Rewrite(Output);
        Write(#7'Abnormal exit:  ');
        IF ExitCode = $FF THEN
          WriteLn('USER BREAK')
        ELSE
          BEGIN
            Write('Critical Error # ', HEX(ExitCode));
            Write(' at program location ');
            WriteLn(HEX(Seg(ErrorAddr^)), ':', Hex(Ofs(ErrorAddr^)));
          END;
      END
    ELSE WriteLn('Normal exit.  ');
    ExitProc := ExitVec;      {restore previous ExitProc}
  END;

BEGIN
  CheckBreak := True;
  ExitVec := ExitProc;
  ExitProc := @My_ExitProc;
  WriteLn('Enter a WORD value:');
  ReadLn(W);
END.

Fig. J -- The TextRec TYPE corresponds to the structure of a TEXT file variable

TYPE
  CharBuf = array[0..127] of char;
  TextRec = RECORD
    Handle    : Word;
    Mode      : Word;
    BufSize   : Word;
    Private   : Word;
    BufPos    : Word;
    BufEnd    : Word;
    BufPtr    : ^CharBuf;
    OpenFunc  : pointer;
    InOutFunc : pointer;
    FlushFunc : pointer;
    CloseFunc : pointer;
    UserData  : Array[1..16] of byte;
    Name      : Array[0..79] of char;
    Buffer    : CharBuf;
  END;

Fig. K -- Using a simulated text file to convert any number of variables into a
single string variable

PROGRAM Usr_file;
  USES Crt;
CONST
  UsrSiz = 255;
  fmClosed = $D7B0;           {"magic" internal codes for TP4}
  fmInput = $D7B1;
  fmOutput = $D7B2;
  fmInOut = $D7B3;
  IO_NotOutput = $104;
  IO_FileFull = $FB;          {You wrote > 255 characters}
  IO_Invalid = $FC;           {You attempted an invalid operation}
TYPE
  String255 = STRING[255];
  CharBuf = ARRAY[0..127] OF Char;
  FakeFile = ARRAY[0..UsrSiz] OF Char;
  TextRec = RECORD
              Handle    : Word;
              Mode      : Word;
              BufSize   : Word;
              Private   : Word;
              BufPos    : Word;
              BufEnd    : Word;
              BufPtr    : ^CharBuf;
              OpenFunc  : pointer;
              InOutFunc : pointer;
              FlushFunc : pointer;
              CloseFunc : pointer;
              {16 bytes for User Data.  We use
              8 of them}
              UFilePos  : Word;
              UFileSiz  : Word;
              Data      : ^FakeFile;
              UserData  : ARRAY[1..8] OF Byte;
              Name      : ARRAY[0..79] OF Char;
              Buffer    : CharBuf;
            END;
VAR
  UsrFile : Text;
  CH      : Char;
  N, D    : Integer;

  {$F+} {Compile functions as FAR routines}
  FUNCTION UsrClose(VAR F : TextRec) : Integer;
    (* "Closes" the UsrFile by deallocating its buffer. *)
    (* Always returns 0, meaning success.               *)
  BEGIN
    Dispose(F.data);
    UsrClose := 0;
  END;

  FUNCTION UsrOutput(VAR F : TextRec) : Integer;
    (* Output to the "file" consists of moving characters from *)
    (* the built-in TextRec buffer to the outside buffer and   *)
    (* adjusting the appropriate pointers.                     *)
  BEGIN
    UsrOutput := 0;
    WITH F DO
      IF mode = fmOutput THEN
        BEGIN
          IF UFilePos+BufPos >= UsrSiz THEN UsrOutput := IO_FileFull
          ELSE
            BEGIN
              Move(BufPtr^, Data^[UFilePos], BufPos);
              UFilePos := UFilePos+BufPos;
              IF UFilePos > UFileSiz THEN UFileSiz := UFilePos;
              BufPos := 0;
            END;
        END
      ELSE
        IF mode = fmClosed THEN UsrOutput := IO_NotOutput
        ELSE UsrOutput := IO_Invalid;
  END;

  FUNCTION UsrOpen(VAR F : TextRec) : Integer;
    (* This particular kind of "file" can _only_ be opened with *)
    (* ReWrite, never with Reset.                               *)
  BEGIN
    UsrOpen := 0;
    WITH F DO
      IF mode = fmOutput THEN
        BEGIN
          UFileSiz := 0;
          UFilePos := 0;
        END
      ELSE UsrOpen := IO_Invalid;
  END;
  {$F-}{Stop compiling functions as FAR routines}

  FUNCTION ReadUsr(VAR F : Text) : String255;
    (* Grab the entire contents of the UsrFile and reset it *)
    (* to empty.                                            *)
  VAR Temp : String255;
  BEGIN
    WITH TextRec(F) DO
      BEGIN
        Move(Data^, Temp[1], UFileSiz);
        Temp[0] := Chr(UFileSiz);
        UFileSiz := 0;
        UFilePos := 0;
      END;
    ReadUsr := temp;
  END;

  PROCEDURE AssignUsr(VAR F : Text);
  BEGIN
    WITH TextRec(F) DO
      BEGIN
        Mode := fmClosed;
        BufSize := 127;
        BufPtr := @buffer;
        OpenFunc := @UsrOpen;
        CloseFunc := @UsrClose;
        InOutFunc := @UsrOutput;
        FlushFunc := @UsrOutput;
        Name[0] := #0;
        UFileSiz := 0;
        UFilePos := 0;
        New(Data);
      END;
  END;

BEGIN
  ClrScr;
  Write('Now writing several variables to "UsrFile" -- ');
  WriteLn('they will become a single STRING.');
  AssignUsr(UsrFile);
  Rewrite(UsrFile);
  Write(UsrFile, 'PI/4 = ', Pi/4:1:11);
  Write(UsrFile, '  The biggest Long Integer is ', MaxLongInt);
  WriteLn('Press a key to see the result.');
  CH := ReadKey;
  WriteLn; WriteLn('"', ReadUsr(UsrFile), '"'); WriteLn;
  WriteLn('Now the UsrFile is clear, ready to accept input again');
  N := 355; D := 113;
  Write(UsrFile, N, '/', D, ' ', Chr(247), ' PI.');
  Write(UsrFile, ' PI=', Pi:1:11, ' and ', N, '/', D, '=', N/D:1:11);
  WriteLn('Press a key to see the result.');
  CH := ReadKey;
  WriteLn; WriteLn('"', ReadUsr(UsrFile), '"'); WriteLn;
  WriteLn('NOW to overload the UsrFile -- we will get a special I/O error');
  WriteLn('Press a key to see the result.');
  CH := ReadKey;
  FOR N := 1 TO 9 DO
    Write(UsrFile, 'THIS string has 32 characters. ');
  WriteLn; WriteLn('"', ReadUsr(UsrFile), '"'); WriteLn;
END.

Fig. L -- Using a "fake OBJ" to incorporate a data file directly into a program.

PROGRAM Fake_Obj;

  {$L INFO.OBJ}
  PROCEDURE InfoProc; EXTERNAL;

  PROCEDURE DisplayInfo(P : Pointer);
  VAR N : Integer;
    S,O : Word;
  BEGIN
    N := -1;
    S := Seg(P^);
    O := Ofs(P^);
    REPEAT
      Inc(N);
      Write(Chr(MEM[S:O+N]));
    UNTIL (MEM[S:O+succ(N)]) = 26;
  END;

BEGIN
  DisplayInfo(@InfoProc);
END.

Fig. M -- TP4 offers conditional compilation

PROGRAM CondComp;
{$IFDEF CPU87}
{$N+}  { turn on use of 8087 math package }
VAR
  X : Single;   { single precision IEEE real }
  Y : Double;   { double precision IEEE real }
  Z : Extended; { extended IEEE real         }
{$ELSE}
VAR
  X : Real;  { no 8087 so define all of them as 6 byte }
  Y : Real;  { reals }
  Z : Real;
{$ENDIF}

BEGIN
  WriteLn('X takes ', SizeOf(X), ' bytes.');
  WriteLn('Y takes ', SizeOf(Y), ' bytes.');
  WriteLn('Z takes ', SizeOf(Z), ' bytes.');
END.

Fig. N -- Demonstrating TP4's direct video I/O

PROGRAM FastWrite;
Uses Crt;
VAR
  AString : String[79];
  N       : Byte;

BEGIN
  FOR N := 1 to 79 DO AString[N] := 'O';
  AString[0] := #79;
  ClrScr;
  WriteLn('Press <Return> for a demo of fast screen writing');
  ReadLn; GotoXY(1,1);
  LowVideo;
  FOR N := 1 to 24 DO WriteLn(AString);
  FOR N := 1 to 79 DO AString[N] := 'X';
  GotoXY(1,1); NormVideo;
  WriteLn('Press <Return> for a demo of ordinary writing');
  ReadLn; GotoXY(1,1);
  DirectVideo := False;
  FOR N := 1 to 24 DO WriteLn(AString);
END.

Fig O. -- A simple UNIT for hexadecimal conversions

UNIT Hexx;

Interface
TYPE
  string2 = STRING[2];
  string4 = STRING[4];

CONST
  HexDigit : ARRAY[0..15] OF Char = '0123456789ABCDEF';

  FUNCTION HexByte(B : Byte) : string2;
  FUNCTION Hex(I : Integer) : string4;

 Implementation

  FUNCTION HexByte(B : Byte) : string2;
  BEGIN
    HexByte := HexDigit[B SHR 4]+HexDigit[B AND $F];
  END;

  FUNCTION Hex(I : Integer) : string4;
  BEGIN
    Hex := HexByte(Hi(I))+HexByte(Lo(I));
  END;
END.